home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / env / build.scm < prev    next >
Text File  |  1995-10-13  |  2KB  |  77 lines
  1. ; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.
  2.  
  3.  
  4. ; Commands for writing images.
  5.  
  6. ; A heap image written using ,dump or ,build can be invoked with
  7. ;    s48 -i <filename> [-h <heap size>] [-a <argument>]
  8. ; For images made with ,build <exp> <filename>, <argument> is passed as
  9. ; a string to the procedure that is the result of <exp>.
  10.  
  11.  
  12. ; dump <filename>
  13.  
  14. (define-command-syntax 'dump "<filename>"
  15.   "write the current heap to an image file"
  16.   '(filename &opt form))
  17.  
  18. (define (dump filename . maybe-info)
  19.   (let ((info (if (null? maybe-info) "(suspended image)" (car maybe-info)))
  20.     (context (user-context))
  21.     (env (environment-for-commands)))
  22.     (build-image (lambda (arg)
  23.            (with-interaction-environment env
  24.              (lambda ()
  25.                (start-command-processor arg
  26.                         context
  27.                         ;; env
  28.                         (lambda ()
  29.                           (greet-user info))))))
  30.          filename)))
  31.  
  32. ; build <exp> <filename>
  33.  
  34. (define-command-syntax 'build "<exp> <filename>"
  35.   "build a heap image file with <exp> as entry procedure"
  36.   '(expression filename))
  37.  
  38. (define (build exp filename)
  39.   (build-image (evaluate exp (environment-for-commands)) filename))
  40.  
  41. ; build-image
  42.  
  43. (define (build-image start filename)
  44.   (let ((filename (translate filename)))
  45.     (write-line (string-append "Writing " filename) (command-output))
  46.     (flush-the-symbol-table!)    ;Gets restored at next use of string->symbol
  47.     (write-image filename
  48.          (stand-alone-resumer start)
  49.          "")
  50.     #t))
  51.  
  52. (define (stand-alone-resumer start)
  53.   (usual-resumer  ;sets up exceptions, interrupts, and current input & output
  54.    (lambda (arg)
  55.      (call-with-current-continuation
  56.        (lambda (halt)
  57.      (with-handler (simple-condition-handler halt (error-output-port))
  58.        (lambda ()
  59.          (start arg))))))))
  60.  
  61. ; Simple condition handler for stand-alone programs.
  62.  
  63. (define (simple-condition-handler halt port)
  64.   (lambda (c punt)
  65.     (cond ((error? c)
  66.        (display-condition c port)
  67.        (halt 1))
  68.       ((warning? c)
  69.        (display-condition c port))        ;Proceed
  70.       ((interrupt? c)
  71.        ;; (and ... (= (cadr c) interrupt/keyboard)) ?
  72.        (halt 2))
  73.       (else
  74.        (punt)))))
  75.  
  76. ;(define interrupt/keyboard (enum interrupt keyboard))
  77.